home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr51 / lib201.zip / SCA.PRG < prev    next >
Text File  |  1993-02-23  |  16KB  |  405 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: SCA.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 02/23/1993
  5. *-- Notes.....: This file contains the SCA Date handling routines, as well as a
  6. *--             copy of the roman numeral to arabic and vice-versa functions,
  7. *--             that are contained in CONVERT.PRG. This is due to the fact
  8. *--             that only two library files may be open at one time. See
  9. *--             the file README.TXT for more details on the use of this library
  10. *--             file.
  11. *-------------------------------------------------------------------------------
  12.  
  13. PROCEDURE SCA_Real
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
  16. *-- Date........: 07/29/1991
  17. *-- Notes.......: This procedure was designed to handle data entered into
  18. *--               the Order of Precedence of the Principality of the Mists.
  19. *--               The problem is, my usual sources of data give only SCA
  20. *--               dates, and in order to sort properly, I need real dates.
  21. *--               This procedure will handle it, and goes hand-in-hand with
  22. *--               the function Real_SCA, to translate real dates to SCA
  23. *--               dates ... This procedure assumes that you have set the
  24. *--               F1 Key (see Example below). If you use a different F key,
  25. *--               you will want to modify the ON KEY LABEL commands ...
  26. *-- Written for.: dBASE IV, 1.1
  27. *-- Rev. History: 07/23/1991 - original procedure.
  28. *--               07/29/1991  -- modified it to stuff a character directly into
  29. *--               a date field (was having to do a CTOD in the program),
  30. *--               and added use of ESC to escape out, instead of killing
  31. *--               the procedure and the program calling it ...
  32. *-- Calls.......: CENTER               Procedure in PROC.PRG
  33. *--               SHADOW               Procedure in PROC.PRG
  34. *--               ARABIC()             Function in PROC.PRG
  35. *--               ALLTRIM()            Function in PROC.PRG
  36. *-- Called by...: Any
  37. *-- Usage.......: do SCA_Real
  38. *-- Example.....: on key label f1 do sca_real
  39. *--               store {} to t_date   && initialize as a date
  40. *--                                    && or you could STORE datefield to t_date
  41. *--                                    && if you have a date field ...
  42. *--               clear
  43. *--               @5,10 say "Enter a date:" get t_date;
  44. *--                  message "Press <F1> to convert from SCA date to real date"
  45. *--               read
  46. *--               on key label f1  && clear out that command ...
  47. *-- Returns.....: real date, forced into field ...
  48. *-- Parameters..: None
  49. *-------------------------------------------------------------------------------
  50.     
  51.     private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,nMonth
  52.     private nDay,cDate
  53.     
  54.     cEscape = set("ESCAPE")
  55.     set escape off            && so we can handle the Escape Key
  56.     cExact = set("EXACT")
  57.     set exact on              && VERY important ...
  58.     on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
  59.                               && again, which causes wierdnesses ...
  60.     *-- first let's popup a window to ask for the information ...
  61.     
  62.     save screen to sDate
  63.     activate screen
  64.     define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  65.     do shadow with 8,20,15,60
  66.     activate window wDate
  67.     
  68.     *-- set the memvars ...
  69.     cYear  = space(8)
  70.     cMonth = space(3)
  71.     cDay   = space(2)
  72.     
  73.     do center with 0,40,"","Enter SCA Date below:"
  74.     do while .t.
  75.         
  76.         @2,14 say "Month: " get cMonth ;
  77.             picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  78.             message "Enter first letter of month, <Space> to scroll through, "+;
  79.                 "<Enter> to choose" color rg+/gb,n/g
  80.         @3,14 say "  Day: " get cDay picture "99";
  81.             message "Enter 2 digits for day of the month, if blank will assume 15";
  82.                 color rg+/gb,n/g
  83.         @4,14 say " Year: " get cYear picture "!!!!!!!!" ;
  84.             message "Enter year in AS roman numeral format";
  85.             valid required len(trim(cYear)) > 0;
  86.             error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
  87.     
  88.         read
  89.     
  90.         if lastkey() = 27                && if user wants out by pressing <Esc>
  91.             deactivate window wDate
  92.             release window wDate
  93.             restore screen from sDate
  94.             release screen sDate
  95.             set escape &cEscape
  96.             set exact &cExact
  97.             on key label F1 do SCA_Real   && reset it ...
  98.             return
  99.         endif
  100.         
  101.         if lastkey() < 0   && function key F1 through Shift F9 was pressed
  102.             ?? chr(7)       && beep at user
  103.             loop            && don't let 'em get away with that -- try again
  104.         endif
  105.         
  106.         *-- check for valid roman numerals
  107.         cYear = trim(cYear)    && trim it
  108.         nYearLen = len(cYear)  && get length
  109.         nCount = 0            
  110.         do while nCount < nYearLen  && loop through length of year
  111.             nCount = nCount + 1      && increment
  112.             if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
  113.                 do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  114.                 lError = .t.          && set error flag
  115.                 exit                  && exit internal loop
  116.             else
  117.                 lError = .f.          && make sure this is false
  118.             endif
  119.         enddo     && end of internal loop
  120.         if lError && if error,
  121.             loop   && go back ...
  122.         endif
  123.         
  124.         @5,0 clear   && clear out any error message ...
  125.         do center with 5,40,"rg+/r","Converting Date ..."
  126.         
  127.         *-- First (and most important) is conversion of the year
  128.         nYear = Arabic(cYear)
  129.         
  130.         *-- AS Years start at May ... if the month for a specific year is
  131.         *-- Jan through April it's part of the next "real" year ...
  132.         if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
  133.                                        cMonth = "APR"
  134.             nYear = nYear + 1
  135.         endif
  136.         
  137.         nYear = nYear + 65  && SCA dates start at 66 ...
  138.         if nYear > 99       && this thing doesn't handle turn of the century
  139.             @5,0 clear
  140.             do center with 5,40,"rg+/r","No dates past XXXIV, please"
  141.             loop
  142.         endif
  143.         
  144.         *-- set numeric value of month ...
  145.         do case
  146.             case cMonth = "JAN"
  147.                 nMonth = 1
  148.             case cMonth = "FEB"
  149.                 nMonth = 2
  150.             case cMonth = "MAR"
  151.                 nMonth = 3
  152.             case cMonth = "APR"
  153.                 nMonth = 4
  154.             case cMonth = "MAY"
  155.                 nMonth = 5
  156.             case cMonth = "JUN"
  157.                 nMonth = 6
  158.             case cMonth = "JUL"
  159.                 nMonth = 7
  160.             case cMonth = "AUG"
  161.                 nMonth = 8
  162.             case cMonth = "SEP"
  163.                 nMonth = 9
  164.             case cMonth = "OCT"
  165.                 nMonth = 10
  166.             case cMonth = "NOV"
  167.                 nMonth = 11
  168.             case cMonth = "DEC"
  169.                 nMonth = 12
  170.         endcase
  171.         
  172.         *-- if the day field is empty, assume the middle of the month, so we
  173.         *-- have SOMETHING to go by ...
  174.         if len(alltrim(cDay)) = 0
  175.             nDay = 15
  176.         else
  177.             nDay = val(cDay)
  178.         endif
  179.         
  180.         *-- Check for valid day of the month ...
  181.         if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
  182.                                  nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
  183.             do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
  184.             loop
  185.         endif
  186.         
  187.         exit                        && out of loop -- if here, we're done
  188.         
  189.     enddo                          && end of loop
  190.  
  191.     *-- Convert it
  192.     cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
  193.               transform(nYear,"@L 99")
  194.     
  195.     *-- force this 'character' date into the date field on the screen ...
  196.     keyboard cDate clear           && put it into the field, and clear out
  197.                                    && keyboard buffer first ...
  198.  
  199.     *-- deal with cleanup ...
  200.     deac wind wDate
  201.     release wind wDate
  202.     restore screen from sDate
  203.     release screen sDate
  204.     set escape &cEscape
  205.     set exact &cExact
  206.     on key label F1 do SCA_Real  && reset for user
  207.     
  208. RETURN
  209. *-- EoP: SCA_Real
  210.  
  211. FUNCTION SCA2Real
  212. *-------------------------------------------------------------------------------
  213. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  214. *-- Date........: 04/22/1992
  215. *-- Notes.......: Jay figured out a short version of SCA_Real above, which
  216. *--               does not use screen input/screen display. This can be used
  217. *--               directly as a function.
  218. *-- Written for.: dBASE IV, 1.5
  219. *-- Rev. History: 04/22/1992 -- Original Release
  220. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  221. *--               ARABIC()             Function in CONVERT.PRG (and below)
  222. *-- Called by...: Any
  223. *-- Usage.......: SCA2Real(<cDay>,<cMonth>,<cYear>)
  224. *-- Example.....: ?SCA2Real("12","JAN","XXVI")
  225. *-- Returns.....: dBASE Date (from example above: 01/12/92)
  226. *-- Parameters..: cDay   = Character day of month
  227. *--               cMonth = Character day of month
  228. *--               cYear  = Roman Numeric version of year (SCA dates)
  229. *-------------------------------------------------------------------------------
  230.  
  231.     parameters cDay, cMonth, cYear
  232.     private nMonth, nDay, nYear
  233.     
  234.     nMonth = at(upper(left(cMonth,3)),"    JAN FEB MAR APR MAY JUN";
  235.               +" JUL AUG SEP OCT NOV DEC") /4
  236.     nDay = iif(""=alltrim(cDay),15,val(cDay))
  237.     nYear = arabic(cYear)+1965+iif(nMonth < 5,1,0)
  238.     
  239. RETURN ctod(right(str(nMonth+100),2)+"/";
  240.          +right(str(nDay+100),2)+"/"+str(nYear))
  241. *-- EoF: SCA2Real()
  242.  
  243. FUNCTION Real_SCA
  244. *-------------------------------------------------------------------------------
  245. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
  246. *-- Date........: 07/23/1991
  247. *-- Notes.......: This procedure was designed to handle data entered into
  248. *--               the Order of Precedence of the Principality of the Mists.
  249. *--               For the purpose of printing the Order of Precedence, it 
  250. *--               is necessary to convert real dates to SCA dates. I needed
  251. *--               to store the data as real dates, but I want it to print with
  252. *--               SCA dates ...
  253. *-- Written for.: dBASE IV, 1.1
  254. *-- Rev. History: 07/23/1991 -- Original Release
  255. *-- Calls.......: ROMAN()              Function in PROC.PRG
  256. *-- Called by...: Any
  257. *-- Usage.......: Real_SCA(<dDate>)
  258. *-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for Corolla 
  259. *--                                           &&   Aulica
  260. *-- Returns.....: SCA Date based on dDate
  261. *-- Parameters..: dDate = date to be converted
  262. *-------------------------------------------------------------------------------
  263.  
  264.     PARAMETERS dDate   && a real date, to be converted to an SCA date ...
  265.     private nYear,nMonth,cMonth,cDay
  266.     
  267.     nYear  = year(dDate) - 1900        && remove the century
  268.     nMonth = month(dDate)
  269.     cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
  270.     cDay   = ltrim(str(day(dDate)))    && convert day to character
  271.     
  272.     *-- First (and most important) is conversion of the year
  273.     *-- this is set to the turn of the century ... (AS XXXV)
  274.     *-- AS Years start at May ... if the month for a specific year is
  275.     *-- Jan through April it's part of the previous SCA year 
  276.     *-- (April '67 = April AS I, not II)
  277.      
  278.     if nMonth < 5
  279.         nYear = nYear - 1
  280.     endif
  281.     
  282.     nYear = nYear - 65   && SCA dates start at 66
  283.     cYear = Roman(nYear)
  284.  
  285. RETURN cMonth+" "+cDay+", "+"AS "+cYear
  286. *-- EoF: Real_SCA()
  287.  
  288. *-------------------------------------------------------------------------------
  289. *-- These two functions were included in this library file, so that you (or I)
  290. *-- do not have to figure a way to combine the functions below from CONVERT.PRG
  291. *-- and this file into one library file.
  292. *-------------------------------------------------------------------------------
  293.  
  294. FUNCTION Roman
  295. *-------------------------------------------------------------------------------
  296. *-- Programmer..: Nick Carlin
  297. *-- Date........: 04/26/1992
  298. *-- Notes.......: A function designed to return a Roman Numeral based on
  299. *--               an Arabic Numeral input ...
  300. *-- Written for.: dBASE III+
  301. *-- Rev. History: 04/13/1988 - original function.
  302. *--               07/25/1991 - Ken Mayer - 1) modified for dBASE IV, 1.1,
  303. *--                             2) updated to a function, and 3) the procedure
  304. *--                             GetRoman was done away with (combined into the
  305. *--                             function).
  306. *--               04/26/1992 - Jay Parsons - shortened (seriously ...)
  307. *-- Calls.......: None
  308. *-- Called by...: Any
  309. *-- Usage.......: Roman(<nArabic>)
  310. *-- Example.....: ? Roman(32)
  311. *-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
  312. *--               passed to it. In example:  XXXII
  313. *-- Parameters..: nArabic = Arabic number to be converted to Roman
  314. *-------------------------------------------------------------------------------
  315.  
  316.    parameters nArabic
  317.    private cLetrs,nCount,nValue,cRoman,cGroup,nMod
  318.     
  319.    cLetrs ="MWYCDMXLCIVX"      && Roman digits
  320.    cRoman = ""                 && this is the returned value
  321.    nCount = 0                  && init counter
  322.    do while nCount < 4         && loop four times, once for thousands, once
  323.                                && for each of hundreds, tens and singles
  324.       nValue = mod( int( nArabic /  10 ^ ( 3 - nCount ) ), 10 )
  325.       cGroup = substr( cLetrs, nCount * 3 + 1, 3 )
  326.       nMod = mod( nValue, 5 )
  327.       if nMod = 4
  328.          if nValue = 9                 && 9
  329.             cRoman = cRoman + left( cGroup, 1 ) + right( cGroup, 1 )
  330.          else                          && 4
  331.             cRoman = cRoman + left( cGroup, 2 )
  332.          endif
  333.       else
  334.          if nValue > 4                 && 5 - 8
  335.             cRoman = cRoman + substr( cGroup, 2, 1 )
  336.          endif
  337.          if nMod > 0                   && 1 - 3 and 6 - 8
  338.             cRoman = cRoman + replicate( left( cGroup, 1 ), nMod )
  339.          endif
  340.       endif
  341.       nCount = nCount + 1
  342.    enddo  && while nCounter < 4
  343.     
  344. RETURN cRoman
  345. *-- EoF: Roman()
  346.  
  347. FUNCTION Arabic
  348. *-------------------------------------------------------------------------------
  349. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  350. *-- Date........: 04/26/1992
  351. *-- Notes.......: This function converts a Roman Numeral to an arabic one.
  352. *--               It parses the roman numeral into an array, and checks each 
  353. *--               character ... if the previous character causes the value to 
  354. *--               subtract (for example, IX = 9, not 10) we subtract that value, 
  355. *--               and then set the previous value to 0, otherwise we would get 
  356. *--               some odd values in return.
  357. *--               So far, it works fine.
  358. *-- Written for.: dBASE IV, 1.1
  359. *-- Rev. History: 07/15/1991 - original function.
  360. *--               04/26/1992 - Jay Parsons - shortened.
  361. *-- Calls.......: None
  362. *-- Called by...: Any
  363. *-- Usage.......: Arabic(<cRoman>)
  364. *-- Example.....: ?Arabic("XXIV")
  365. *-- Returns.....: Arabic number (from example, 24)
  366. *-- Parameters..: cRoman = character string containing roman numeral to be
  367. *--               converted.
  368. *-------------------------------------------------------------------------------
  369.  
  370.         parameters cRoman
  371.         private cRom,cLetrs,nLast,nAt,nVal,cChar,nArabic
  372.     
  373.         cRom = ltrim(trim(upper(cRoman))) && convert to all caps in case ...
  374.         cLetrs = "IVXLCDMWY"
  375.         nArabic = 0
  376.         nLast = 0
  377.         do while len( cRom ) > 0
  378.                 cChar = right( cRom, 1 )
  379.                 nAt = at( cChar, cLetrs )
  380.                 nVal= 10 ^ int( nAt/2 ) / iif(nAt/2 = int(nAt/2),2,1)
  381.                 do case
  382.                         case nAt = 0
  383.                                 nArabic = 0
  384.                                 exit
  385.                         case nAt >= nLast
  386.                                 nArabic = nArabic + nVal
  387.                                 nLast = nAt
  388.                         otherwise
  389.                                 if nAt/2 = int( nAt / 2 )
  390.                                         nArabic = 0
  391.                                         exit
  392.                                 else
  393.                                         nArabic = nArabic - nVal
  394.                                 endif
  395.                 endcase
  396.                 cRom = left( cRom, len( cRom ) - 1 )
  397.         enddo
  398.     
  399. RETURN nArabic
  400. *-- EoF: Arabic()
  401.  
  402. *-------------------------------------------------------------------------------
  403. *-- EoP: SCA.PRG
  404. *-------------------------------------------------------------------------------
  405.